home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr01 / halcn305.zip / GSOBSHEL.PAS < prev    next >
Pascal/Delphi Source File  |  1993-08-01  |  30KB  |  1,154 lines
  1. unit GSOBShel;
  2. {-----------------------------------------------------------------------------
  3.                            dBase III/IV File Handler
  4.  
  5.        GSOBSHEL Copyright (c)   Richaard F. Griffin
  6.  
  7.        29 January 1993
  8.  
  9.        102 Molded Stone Pl
  10.        Warner Robins, GA  31088
  11.  
  12.        -------------------------------------------------------------
  13.        This unit provides access to Griffin Solutions dBase Objects
  14.        using high-level procedures and functions that make Object
  15.        Oriented Programming transparent to the user.  It provides a
  16.        selection of commands similar to the dBase format.
  17.  
  18.    Changes:
  19.  
  20.       19 Apr 93 - Procedure Go() modified to position the master index
  21.                   file (if one is open) at the correct index entry for
  22.                   the physical record that is read.  This ensures that
  23.                   indexed sequential reads are in sync after a physical
  24.                   record access.
  25.  
  26.       02 May 93 - Routines used for conversion to/from numbers have been
  27.                   modified to be of type FloatNum.  This allows numbers to
  28.                   have up to 20 significant digits.  Note that the $N+ and
  29.                   $E+ switches must be set (Alt O,C,8,E in IDE) to compile
  30.                   using this feature.  Otherwise, 11-12 digits will be used.
  31.                   The use of the $N+,E+ switch adds 10K to program size.
  32.  
  33.                   When you compile a program in the $N+,E+ state, the
  34.                   compiler links with the full 80x87 emulator.  The resulting
  35.                   .EXE file can be run on any machine, regardless of whether
  36.                   that machine has an 80x87. If an 80x87 is present, the
  37.                   program will use it; otherwise, the run-time library
  38.                   emulates it.  This gives you access to four additional
  39.                   real types: Single, Double, Extended, and Comp.  The $E+
  40.                   directive will emulate the 80x87. This gives you access
  41.                   to the IEEE floating-point types without requiring that you
  42.                   install an 80x87 chip.
  43.  
  44.       03 Jun 93 - Fixed CloseDataBases to release the objects by using Dispose
  45.                   and the Done destructor instead of only Close.
  46.  
  47.       21 Jun 93 - Increased speed of index access in the Go procedure by
  48.                   getting the formula and Finding the index record rather
  49.                   than using the sequential search for a matching record
  50.                   through KeyLocRec.
  51.  
  52.       24 Jul 93 - Modified Find to call object^.FindNear.  Now, the file
  53.                   will be positioned at the record with the next greater
  54.                   key if no match and the search did not go to end of file.
  55.                   The programmer can call Found to see if there was a match,
  56.                   and dEOF to see if the file is positioned at the end of
  57.                   file (true), or at the next greater key (false).
  58.  
  59.       25 Jul 93 - Improved the speed of setting indexes in the Select
  60.                   method.  Replaced routine to do a sequential search for the
  61.                   index key with record number matching the current number.
  62.                   New routine Finds matching record key and then confirms the
  63.                   record number matches.  Provides significant reduction in
  64.                   time required.
  65.  
  66.       28 Jul 93 - Added the following call to allow user formula expression
  67.                   processing for indexes:
  68.  
  69.                   Procedure  SetFormulaProcess(UserRoutine1 : FormulaProc;
  70.                                                UserRoutine2: XtractFunc);
  71.  
  72.                   Assigns two user-supplied routines to process formulas to
  73.                   be built and used by index files.  This call replaces the
  74.                   default DefFormulaBuild and DefFormulaXtract with the
  75.                   programmer's own routine via a call to SetFormulaProcess.
  76.  
  77.                   The Formula routine in HALCYON only handles straight field
  78.                   names.  However, the SetFormulaProcess allows a user-
  79.                   supplied routine to be called anytime a formula is needed
  80.                   for an index action from anywhere within the ancestor
  81.                   object(s).
  82.  
  83.                   Two routines must be provided.  UserRoutine1 is a routine
  84.                   that parses the expression and translates into paramaters
  85.                   are understood by UserRoutine2.  UserRoutine2 is called
  86.                   everytime a index key is to be extracted from a record.
  87.  
  88.                   In this example, substrings of the first five positions
  89.                   of the LASTNAME and FIRSTNAME fields are combined in a
  90.                   string that is then returned as the formula's result.
  91.  
  92.                   The IndexOn command must contain the correct formula;
  93.                   for example:
  94.  
  95.                   IndexOn('DEMOFRM2',
  96.                           'SUBSTR(LASTNAME,1,5)+SUBSTR(FIRSTNAME,1,5)');
  97.  
  98.                   so it will be stored properly in the index header for use
  99.                   by other programs such as dBase, FoxPro, Clipper, etc.
  100.  
  101.  
  102.                  ($F+)
  103.                  Function UFormula(st:string;var fmrec:GSR_FormRec): boolean;
  104.                  var FldCnt : integer;
  105.                  begin
  106.                     if (fmrec.FAlias = 'TESTFRM2') then  (Correct Index?)
  107.                     begin                                (set extract table)
  108.                        UFormula := true;
  109.                        for FldCnt := 0 to 32 do fmrec.FPosn[FldCnt] := 0;
  110.                        fmrec.FType := 'C';  (Character key)
  111.                        fmrec.FDcml := 0;
  112.                        fmrec.FSize := 10; (5 chars from LASTNAME & FIRSTNAME)
  113.                     end
  114.                     else UFormula := true;
  115.                  end;
  116.  
  117.                  Function UFormXtract(var st:string;fmrec:GSR_FormRec):boolean;
  118.                  begin
  119.                     if (fmrec.FAlias = 'TESTFRM2') then    (Correct index?)
  120.                     begin
  121.                        UFormXtract := true;
  122.                        st := SubStr(FieldGet('LASTNAME'),1,5) +
  123.                        SubStr(FieldGet('FIRSTNAME'),1,5);
  124.                     end
  125.                     else UFormXtract := false;
  126.                  end;
  127.                  ($F-)
  128.                                       .
  129.                                       .
  130.                                       .
  131.                 Select(1);
  132.                 Use('GSDMO_01');
  133.                 SetFormulaProcess(UFormula, UFormXtract);
  134.                                       .
  135.                                       .
  136.  
  137.  
  138.                  To return to the default, simply use:
  139.  
  140.                  SetFormulaProcess(DefFormulaBuild, DefFormulaXtract);
  141.  
  142.                  Note that the assigned procedure must use far calls ($F+).
  143.                  Also note that SetFormulaProcess should not be called until
  144.                  a file has been assigned to the selected file area through
  145.                  Use.  If no file has been assigned, Error 1008, Object is
  146.                  not initialized in file area, will halt the program.
  147.  
  148.                  See TESTFRM1.PAS and TESTFRM2.PAS for demonstrations of
  149.                  this function.
  150.  
  151.       02 Aug 93 - Fixed problem in the Use command that did not clear the
  152.                   Object pointer when the used file changed.  This was no
  153.                   problem except when the area was cleared (Use('')), and
  154.                   then Use'd again.  Since the object pointer in the table
  155.                   was invalid, an error occured.
  156.  
  157. ------------------------------------------------------------------------------}
  158. interface
  159.  
  160. uses
  161.    GSOB_Var,
  162.    GSOB_Str,
  163.    GSOB_DBF,
  164.    GSOB_DBS,
  165.    GSOB_Dsk,
  166.    GSOB_Dte,
  167.    {$IFDEF WINDOWS}
  168.       WinDos,
  169.       Strings;
  170.    {$ELSE}
  171.       Dos;
  172.    {$ENDIF}
  173.  
  174. type
  175.    CaptureError  = Procedure(Code, Info: Integer);
  176.    CaptureStatus = Procedure(stat1,stat2,stat3 : longint);
  177.    FilterCheck   = Function: boolean;
  178.    FormulaProc   = Function(st: string; var fmrec : GSR_FormRec): boolean;
  179.    XtractFunc    = Function(var st: string; fmrec: GSR_FormRec): boolean;
  180.  
  181.    pDBFObject = ^DBFObject;
  182.    DBFObject = object(GSO_dBHandler)
  183.       DBFAlias    : string[10];
  184.       DBFFilter   : FilterCheck;
  185.       DBFFormula  : FormulaProc;
  186.       DBFXtract   : XtractFunc;
  187.       constructor Init(FName : string);
  188.       Procedure   Error(Code, Info: Integer); virtual;
  189.       Procedure   Formula(st : string; var fmrec : GSR_FormRec); virtual;
  190.       Function    FormXtract(fmrec : GSR_FormRec) : string; virtual;
  191.       Procedure   StatusUpdate(stat1,stat2,stat3 : longint); virtual;
  192.       Function    TestFilter : boolean; virtual;
  193.    end;
  194.  
  195. var
  196.    CapError   : CaptureError;
  197.    CapStatus  : CaptureStatus;
  198.    DBFActive  : pDBFObject;
  199.    DBFUsed    : integer;
  200.    DBFAreas   : array[0..40] of pDBFObject;
  201.    LastError  : integer;
  202.  
  203.    Function   Alias : string;
  204.    Function   ALock : boolean;
  205.    Procedure  Append;
  206.    Procedure  ClearRecord;
  207.    Procedure  CloseDataBases;
  208.    Procedure  CopyStructure(filname : string);
  209.    Procedure  CopyTo(filname : string);
  210.    Function   CurrentArea : byte;
  211.    Function   Date: longint;
  212.    Function   DBF : string;
  213.    Function   DBFError : integer;
  214.    Function   dBOF : boolean;
  215.    Function   Deleted : boolean;
  216.    Procedure  DeleteRec;
  217.    Function   dEOF : boolean;
  218.    Function   Field(n : byte) : string;
  219.    Function   FieldCount : byte;
  220.    Function   FieldDec(n : byte) : byte;
  221.    Function   FieldLen(n : byte) : byte;
  222.    Function   FieldNo(fn : string) : byte;
  223.    Function   FieldType(n : byte) : char;
  224.    Function   FileExist(FName : string) : boolean;
  225.    Procedure  Find(ss : string);
  226.    Function   FLock : boolean;
  227.    Procedure  FlushDBF;
  228.    Function   Found : boolean;
  229.    Procedure  Go(n : longint);
  230.    Procedure  GoBottom;
  231.    Procedure  GoTop;
  232.    Procedure  Index(INames : string);
  233.    Procedure  IndexOn(filname, formla : string);
  234.    Function   LUpdate: string;
  235.    Procedure  Pack;
  236.    Procedure  RecallRec;
  237.    Function   RecCount : longint;
  238.    Function   RecNo : longint;
  239.    Function   RecSize : word;
  240.    Procedure  Reindex;
  241.    Procedure  Replace;
  242.    Function   RLock : boolean;
  243.    Procedure  Select(Obj : byte);
  244.    Procedure  SetCenturyOff;
  245.    Procedure  SetCenturyOn;
  246.    Procedure  SetDateStyle(dt : DateTypes);
  247.    Procedure  SetDBFCacheOff;
  248.    Procedure  SetDBFCacheOn;
  249.    Procedure  SetDeletedOff;
  250.    Procedure  SetDeletedOn;
  251.    Procedure  SetErrorCapture(UserRoutine : CaptureError);
  252.    Procedure  SetExactOff;
  253.    Procedure  SetExactOn;
  254.    Procedure  SetExclusiveOff;
  255.    Procedure  SetExclusiveOn;
  256.    Procedure  SetFileHandles(hndls : byte);
  257.    Procedure  SetFilterThru(UserRoutine : FilterCheck);
  258.    Procedure  SetFlushOff;
  259.    Procedure  SetFlushOnAppend;
  260.    Procedure  SetFlushOnWrite;
  261.    Procedure  SetFormulaProcess(UserRoutine1 : FormulaProc;
  262.                                 UserRoutine2: XtractFunc);
  263.    Procedure  SetLockOff;
  264.    Procedure  SetLockOn;
  265.    Procedure  SetOrderTo(order : integer);
  266.    Procedure  SetStatusCapture(UserRoutine : CaptureStatus);
  267.    Procedure  Skip(n : longint);
  268.    Procedure  SortTo(filname, formla: string; sortseq: SortStatus);
  269.    Procedure  Unlock;
  270.    Procedure  UnlockAll;
  271.    Procedure  Use(FName : string);
  272.    Procedure  Zap;
  273.  
  274.      {dBase field handling routines}
  275.  
  276.    Procedure  AssignMemo(st, nm : string);
  277.    Procedure  SaveMemo(st, nm : string);
  278.    Procedure  MemoClear;
  279.    function   MemoGetLine(linenum : integer) : string;
  280.    Procedure  MemoInsLine(linenum : integer; st : string);
  281.    procedure  MemoGet(st : string);
  282.    procedure  MemoGetN(n : integer);
  283.    Procedure  MemoWidth(l : integer);
  284.    function   MemoLines : integer;
  285.    procedure  MemoPut(st : string);
  286.    procedure  MemoPutN(n : integer);
  287.    Function   DateGet(st : string) : longint;
  288.    Function   DateGetN(n : integer) : longint;
  289.    Procedure  DatePut(st : string; jdte : longint);
  290.    Procedure  DatePutN(n : integer; jdte : longint);
  291.    Function   FieldGet(fnam : string) : string;
  292.    Function   FieldGetN(fnum : integer) : string;
  293.    Procedure  FieldPut(fnam, st : string);
  294.    Procedure  FieldPutN(fnum : integer; st : string);
  295.    Function   LogicGet(st : string) : boolean;
  296.    Function   LogicGetN(n : integer) : boolean;
  297.    Procedure  LogicPut(st : string; b : boolean);
  298.    Procedure  LogicPutN(n : integer; b : boolean);
  299.    Function   NumberGet(st : string) : FloatNum;
  300.    Function   NumberGetN(n : integer) : FloatNum;
  301.    Procedure  NumberPut(st : string; r : FloatNum);
  302.    Procedure  NumberPutN(n : integer; r : FloatNum);
  303.    Function   StringGet(fnam : string) : string;
  304.    Function   StringGetN(fnum : integer) : string;
  305.    Procedure  StringPut(fnam, st : string);
  306.    Procedure  StringPutN(fnum : integer; st : string);
  307.  
  308.      {dBase type functions}
  309.  
  310. function CTOD(strn : string) : longint;
  311. function DTOC(jul : longint) : string;
  312. function DTOS(jul : longint) : string;
  313.  
  314.      {Default capture procedures}
  315.  
  316. Procedure DefCapError(Code, Info : integer);
  317. Procedure DefCapStatus(stat1,stat2,stat3 : longint);
  318. Function  DefFilterCk: boolean;
  319. Function  DefFormulaBuild(st: string; var fmrec: GSR_FormRec): boolean;
  320. Function  DefFormulaXtract(var st: string; fmrec: GSR_FormRec): boolean;
  321.  
  322.  
  323. implementation
  324.  
  325.  
  326. {-----------------------------------------------------------------------------
  327.                             Data Capture Procedures
  328. ------------------------------------------------------------------------------}
  329.  
  330. Constructor DBFObject.Init(FName : string);
  331. begin
  332.    GSO_dBHandler.Init(FName);
  333.    DBFFilter := DefFilterCk;
  334.    DBFFormula := DefFormulaBuild;
  335.    DBFXtract := DefFormulaXtract;
  336. end;
  337.  
  338. Procedure DBFObject.Error(Code, Info : integer);
  339. begin
  340.    CapError(Code, Info);
  341. end;
  342.  
  343. Procedure DBFObject.Formula(st : string; var fmrec : GSR_FormRec);
  344. begin
  345.    if not DBFFormula(st, fmrec) then GSO_dBHandler.Formula(st, fmrec);
  346. end;
  347.  
  348. Function  DBFObject.FormXtract(fmrec : GSR_FormRec) : string;
  349. var
  350.    st : string;
  351. begin
  352.    if DBFXtract(st, fmrec) then FormXtract := st
  353.    else FormXtract := GSO_dBHandler.FormXtract(fmrec);
  354. end;
  355.  
  356. Procedure DBFObject.StatusUpdate(stat1,stat2,stat3 : longint);
  357. begin
  358.    CapStatus(stat1,stat2,stat3);
  359. end;
  360.  
  361. Function DBFObject.TestFilter : boolean;
  362. begin
  363.    if DBFFilter then
  364.       TestFilter := GSO_dBHandler.TestFilter
  365.    else
  366.       TestFilter := false;
  367. end;
  368.  
  369.  
  370.                     {Default capture routines}
  371.  
  372. {$F+}
  373. Procedure DefCapError(Code, Info : integer);
  374. begin
  375.    RunError(Code);
  376. end;
  377.  
  378. Procedure DefCapStatus(stat1,stat2,stat3 : longint);
  379. begin
  380. end;
  381.  
  382. Function DefFilterCk: boolean;
  383. begin
  384.    DefFilterCk := true;
  385. end;
  386.  
  387. Function DefFormulaBuild(st: string; var fmrec : GSR_FormRec): boolean;
  388. begin
  389.    DefFormulaBuild := false;
  390. end;
  391.  
  392. Function  DefFormulaXtract(var st: string; fmrec: GSR_FormRec): boolean;
  393. begin
  394.    DefFormulaXtract := false;
  395. end;
  396. {$F-}
  397. {-----------------------------------------------------------------------------
  398.                         High-Level Procedures/Functions
  399. ------------------------------------------------------------------------------}
  400.  
  401. Procedure ConfirmUsedArea;
  402. begin
  403.    if DBFActive = nil then RunError(gsAreaIsNotInUse);
  404. end;
  405.  
  406. Function Alias : string;
  407. begin
  408.    if DBFActive <> nil then
  409.       Alias := DBFActive^.DBFAlias
  410.    else Alias := '';
  411. end;
  412.  
  413. Function ALock : boolean;
  414. begin
  415.    ConfirmUsedArea;
  416.    ALock := DBFActive^.LokApnd;
  417. end;
  418.  
  419. Procedure Append;
  420. begin
  421.    ConfirmUsedArea;
  422.    DBFActive^.Append;
  423. end;
  424.  
  425. Procedure ClearRecord;
  426. begin
  427.    ConfirmUsedArea;
  428.    DBFActive^.Blank;
  429. end;
  430.  
  431. Procedure CloseDatabases;
  432. var i : integer;
  433. begin
  434.    for i := 1 to 40 do
  435.       if DBFAreas[i] <> nil then
  436.       begin
  437.          Dispose(DBFAreas[i], Done);
  438.          DBFAreas[i] := nil;
  439.       end;
  440. end;
  441.  
  442. Procedure  CopyStructure(filname : string);
  443. begin
  444.    ConfirmUsedArea;
  445.    DBFActive^.CopyStructure(filname);
  446. end;
  447.  
  448. Procedure  CopyTo(filname : string);
  449. begin
  450.    ConfirmUsedArea;
  451.    DBFActive^.CopyFile(filname);
  452. end;
  453.  
  454. function CTOD(strn : string) : longint;
  455. var
  456.    v : longint;
  457. begin
  458.    v := GS_Date_Juln(strn);
  459.    if v > 0 then CTOD := v else CTOD := 0;
  460. end;
  461.  
  462. Function CurrentArea : byte;
  463. begin
  464.    CurrentArea := DBFUsed;
  465. end;
  466.  
  467. Function Date: longint;
  468. begin
  469.    Date := GS_Date_Curr;
  470. end;
  471.  
  472. {$IFDEF WINDOWS}
  473. Function DBF : string;
  474. var
  475.    ExpFile : PChar;
  476. begin
  477.    if DBFActive = nil then DBF := ''
  478.       else
  479.       begin
  480.          GetMem(ExpFile, 80);
  481.          StrPCopy(ExpFile, DBFActive^.dfFileName);
  482.          FileExpand(ExpFile, ExpFile);
  483.          DBF := ExpFile^;
  484.          FreeMem(ExpFile, 80);
  485.       end;
  486. end;
  487. {$ELSE}
  488. Function DBF : string;
  489. begin
  490.    if DBFActive = nil then DBF := ''
  491.       else DBF := FExpand(DBFActive^.dfFileName);
  492. end;
  493. {$ENDIF}
  494.  
  495.  
  496. Function DBFError : integer;
  497. begin
  498.    ConfirmUsedArea;
  499.    DBFError := LastError;
  500.    LastError := 0;
  501. end;
  502.  
  503. Function dBOF : boolean;
  504. begin
  505.    ConfirmUsedArea;
  506.    dBOF := DBFActive^.File_TOF;
  507. end;
  508.  
  509. Function Deleted : boolean;
  510. begin
  511.    ConfirmUsedArea;
  512.    Deleted := DBFActive^.DelFlag;
  513. end;
  514.  
  515. Procedure DeleteRec;
  516. begin
  517.    ConfirmUsedArea;
  518.    DBFActive^.Delete;
  519. end;
  520.  
  521. Function dEOF : boolean;
  522. begin
  523.    ConfirmUsedArea;
  524.    dEOF := DBFActive^.File_EOF;
  525. end;
  526.  
  527. function DTOC(jul : longint) : string;
  528. begin
  529.    DTOC := GS_Date_View(jul);
  530. end;
  531.  
  532. function DTOS(jul : longint) : string;
  533. begin
  534.    DTOS := GS_Date_DBStor(jul);
  535. end;
  536.  
  537. Function Field(n : byte) : string;
  538. var
  539.    st : string;
  540. begin
  541.    ConfirmUsedArea;
  542.    st := DBFActive^.FieldName(n);
  543.    if st = '' then LastError := 220 else LastError := 0;
  544.    Field := st;
  545. end;
  546.  
  547. Function FieldCount : byte;
  548. begin
  549.    ConfirmUsedArea;
  550.    FieldCount := DBFActive^.NumFields;
  551. end;
  552.  
  553. Function FieldDec(n : byte) : byte;
  554. begin
  555.    ConfirmUsedArea;
  556.    FieldDec := DBFActive^.FieldDecimals(n);
  557. end;
  558.  
  559. Function FieldLen(n : byte) : byte;
  560. begin
  561.    ConfirmUsedArea;
  562.    FieldLen := DBFActive^.FieldLength(n);
  563. end;
  564.  
  565. Function FieldNo(fn : string) : byte;
  566. var
  567.    mtch : boolean;
  568.    i,
  569.    ix   : integer;
  570.    za   : string[16];
  571. begin
  572.    ConfirmUsedArea;
  573.    fn := TrimR(AllCaps(fn));
  574.    ix := DBFActive^.NumFields;
  575.    i := 1;
  576.    mtch := false;
  577.    while (i <= ix) and not mtch do
  578.    begin
  579.       CnvAscToStr(DBFActive^.Fields^[i].FieldName,za,11);
  580.       if za = fn then mtch := true else inc(i);
  581.    end;
  582.    if mtch then FieldNo := i else FieldNo := 0;
  583. end;
  584.  
  585. Function FieldType(n : byte) : char;
  586. begin
  587.    ConfirmUsedArea;
  588.    FieldType := DBFActive^.FieldType(n);
  589. end;
  590.  
  591. Function FileExist(FName : string): boolean;
  592. begin
  593.    FileExist := GS_FileExists(FName);
  594. end;
  595.  
  596. Procedure Find(ss : string);
  597. var b : boolean;
  598. begin
  599.    ConfirmUsedArea;
  600.    b := DBFActive^.FindNear(ss);
  601. end;
  602.  
  603. Function FLock : boolean;
  604. begin
  605.    ConfirmUsedArea;
  606.    FLock := DBFActive^.LokFile;
  607. end;
  608.  
  609. Procedure FlushDBF;
  610. begin
  611.    ConfirmUsedArea;
  612.    DBFActive^.Flush;
  613. end;
  614.  
  615. Function Found : boolean;
  616. begin
  617.    ConfirmUsedArea;
  618.    Found := DBFActive^.Found;
  619. end;
  620.  
  621. Procedure Go(n : longint);
  622. var
  623.    b : longint;
  624.    s : string;
  625. begin
  626.    ConfirmUsedArea;
  627.    if (n < 1) or (n > DBFActive^.NumRecs) then exit;
  628.    DBFActive^.GetRec(n);
  629.    if DBFActive^.IndexMaster <> nil then
  630.    begin
  631.       s := DBFActive^.FormXtract(DBFActive^.IndexMaster^.FormRec);
  632.       b := DBFActive^.IndexMaster^.KeyFind(s);
  633.       while (b <> n) and (b <> 0) do
  634.          b := DBFActive^.IndexMaster^.KeyRead(Next_Record);
  635.    end;
  636. end;
  637.  
  638. Procedure GoBottom;
  639. begin
  640.    ConfirmUsedArea;
  641.    DBFActive^.GetRec(Bttm_Record);
  642. end;
  643.  
  644. Procedure GoTop;
  645. begin
  646.    ConfirmUsedArea;
  647.    DBFActive^.GetRec(Top_Record);
  648. end;
  649.  
  650. Procedure Index(INames : string);
  651. begin
  652.    ConfirmUsedArea;
  653.    if INames <> '' then SetDBFCacheOff;
  654.    DBFActive^.Index(INames);
  655. end;
  656.  
  657. Procedure IndexOn(filname, formla: string);
  658. var order : integer;
  659. begin
  660.    ConfirmUsedArea;
  661.    SetDBFCacheOff;
  662.    order := DBFActive^.IndexTo(filname, formla);
  663. end;
  664.  
  665. Function LUpdate: string;
  666. var
  667.    yy, mm, dd : word;
  668.    hh, mn, ss : word;
  669.    fd         : longint;
  670. begin
  671.    if DBFActive = nil then LUpdate := ''
  672.    else
  673.    begin
  674.       GS_FileDateTime(DBFActive^.dfFiletype,yy,mm,dd,hh,mn,ss);
  675.       fd := GS_Date_MDY2Jul(mm,dd,yy);
  676.       LUpdate := GS_Date_View(fd);
  677.    end;
  678. end;
  679.  
  680. Procedure Pack;
  681. begin
  682.    ConfirmUsedArea;
  683.    DBFActive^.Pack;
  684. end;
  685.  
  686. Procedure RecallRec;
  687. begin
  688.    ConfirmUsedArea;
  689.    DBFActive^.Undelete;
  690. end;
  691.  
  692. Function RecCount : longint;
  693. begin
  694.    ConfirmUsedArea;
  695.    RecCount := DBFActive^.RecsInFile;
  696. end;
  697.  
  698. Function RecNo : longint;
  699. begin
  700.    ConfirmUsedArea;
  701.    RecNo := DBFActive^.RecNumber;
  702. end;
  703.  
  704. Function RecSize : word;
  705. begin
  706.    ConfirmUsedArea;
  707.    RecSize := DBFActive^.RecLen;
  708. end;
  709.  
  710. Procedure Reindex;
  711. begin
  712.    ConfirmUsedArea;
  713.    DBFActive^.Reindex;
  714. end;
  715.  
  716. Procedure Replace;
  717. begin
  718.    ConfirmUsedArea;
  719.    DBFActive^.Replace;
  720. end;
  721.  
  722. Function RLock : boolean;
  723. begin
  724.    ConfirmUsedArea;
  725.    RLock := DBFActive^.LokRcrd;
  726. end;
  727.  
  728. Procedure Select(Obj : byte);
  729. var
  730.    b : longint;
  731.    s : string;
  732. begin
  733.    if (Obj < 1) or (Obj > 40) then exit;
  734.    DBFUsed := Obj;
  735.    DBFActive := DBFAreas[Obj];
  736.    if DBFActive <> nil then
  737.       if DBFActive^.IndexMaster <> nil then
  738.          if DBFActive^.RecNumber = 0 then GoTop
  739.          else
  740.          begin
  741.             s := DBFActive^.FormXtract(DBFActive^.IndexMaster^.FormRec);
  742.             b := DBFActive^.IndexMaster^.KeyFind(s);
  743.             while (b <> DBFActive^.RecNumber) and (b <> 0) do
  744.                b := DBFActive^.IndexMaster^.KeyRead(Next_Record);
  745.          end;
  746. end;
  747.  
  748. Procedure SetCenturyOff;
  749. begin
  750.    SetCentury(Off);
  751. end;
  752.  
  753. Procedure SetCenturyOn;
  754. begin
  755.    SetCentury(On);
  756. end;
  757.  
  758. Procedure SetDateStyle(dt : DateTypes);
  759. begin
  760.    GS_Date_Type := DateCountry(dt);
  761. end;
  762.  
  763. Procedure SetDBFCacheOff;
  764. begin
  765.    ConfirmUsedArea;
  766.    DBFActive^.SetDBFCache(Off);
  767. end;
  768.  
  769. Procedure SetDBFCacheOn;
  770. begin
  771.    ConfirmUsedArea;
  772.    if DBFActive^.IndexMaster <> nil then exit;
  773.    DBFActive^.SetDBFCache(On);
  774. end;
  775.  
  776. Procedure SetDeletedOff;
  777. begin
  778.    SetDeleted(Off);
  779. end;
  780.  
  781. Procedure SetDeletedOn;
  782. begin
  783.    SetDeleted(On);
  784. end;
  785.  
  786. Procedure SetErrorCapture(UserRoutine : CaptureError);
  787. begin
  788.    CapError := UserRoutine;
  789. end;
  790.  
  791. Procedure SetExactOff;
  792. begin
  793.    SetExact(Off);
  794. end;
  795.  
  796. Procedure SetExactOn;
  797. begin
  798.    SetExact(On);
  799. end;
  800.  
  801. Procedure SetExclusiveOff;
  802. begin
  803.    GS_SetExclusive(Off);
  804. end;
  805.  
  806. Procedure SetExclusiveOn;
  807. begin
  808.    GS_SetExclusive(On);
  809. end;
  810.  
  811. Procedure SetFileHandles(hndls : byte);
  812. var
  813.    b : boolean;
  814. begin
  815.    b := GS_ExtendHandles(hndls);
  816. end;
  817.  
  818. Procedure SetFilterThru(UserRoutine : FilterCheck);
  819. begin
  820.    ConfirmUsedArea;
  821.    DBFActive^.DBFFilter := UserRoutine;
  822. end;
  823.  
  824. Procedure SetFlushOff;
  825. begin
  826.    ConfirmUsedArea;
  827.    DBFActive^.dfFileFlsh := NeverFlush;
  828. end;
  829.  
  830. Procedure SetFlushOnAppend;
  831. begin
  832.    ConfirmUsedArea;
  833.    DBFActive^.dfFileFlsh := AppendFlush;
  834. end;
  835.  
  836. Procedure SetFlushOnWrite;
  837. begin
  838.    ConfirmUsedArea;
  839.    DBFActive^.dfFileFlsh := WriteFlush;
  840. end;
  841.  
  842. Procedure SetFormulaProcess(UserRoutine1 : FormulaProc;
  843.                             UserRoutine2: XtractFunc);
  844. begin
  845.    DBFActive^.DBFFormula := UserRoutine1;
  846.    DBFActive^.DBFXtract := UserRoutine2;
  847. end;
  848.  
  849. Procedure SetLockOff;
  850. var i : integer;
  851. begin
  852.    GS_ShareAuto(Off);
  853. end;
  854.  
  855. Procedure SetLockOn;
  856. begin
  857.    GS_ShareAuto(On);
  858. end;
  859.  
  860. Procedure SetOrderTo(order : integer);
  861. var b : boolean;
  862. begin
  863.    ConfirmUsedArea;
  864.    b := DBFActive^.IndexOrder(order);
  865. end;
  866.  
  867. Procedure SetStatusCapture(UserRoutine : CaptureStatus);
  868. begin
  869.    CapStatus := UserRoutine;
  870. end;
  871.  
  872. Procedure Skip(n : longint);
  873. begin
  874.    ConfirmUsedArea;
  875.    DBFActive^.Skip(n);
  876. end;
  877.  
  878. Procedure SortTo(filname, formla: string; sortseq : SortStatus);
  879. begin
  880.    ConfirmUsedArea;
  881.    DBFActive^.SortFile(filname, formla, sortseq);
  882. end;
  883.  
  884. Procedure Unlock;
  885. var
  886.    i   : integer;
  887.    rsl : word;
  888. begin
  889.    ConfirmUsedArea;
  890.    DBFActive^.LokOff;
  891.    if DBFActive^.WithMemo then rsl := DBFActive^.MemoFile^.Unlock;
  892.    for i := 1 to IndexesAvail do
  893.       if DBFActive^.IndexStack[i] <> nil then
  894.          rsl := DBFActive^.IndexStack[i]^.Unlock;
  895. end;
  896.  
  897. Procedure UnlockAll;
  898. var i : integer;
  899. begin
  900.    for i := 1 to 40 do
  901.       if DBFAreas[i] <> nil then
  902.          while DBFAreas[i]^.dfLockRec do DBFAreas[i]^.LokOff;
  903.    GS_ClearLocks;
  904. end;
  905.  
  906. Procedure Use(FName : string);
  907. var i,j : integer;
  908. begin
  909.    if DBFActive <> nil then dispose(DBFActive, Done);
  910.    DBFActive := nil;
  911.    DBFAreas[DBFUsed] := DBFActive;
  912.    if FName = '' then exit;
  913.    DBFActive := New(pDBFObject, Init(FName));
  914.    DBFActive^.Open;
  915.    DBFAreas[DBFUsed] := DBFActive;
  916.    FName := AllCaps(TrimR(FName));
  917.    i := length(FName);
  918.    j := i;
  919.    while (i > 0) and not (FName[i] in ['\',':']) do dec(i);
  920.    DBFActive^.DBFAlias := copy(FName,i+1,(j-i));
  921. end;
  922.  
  923. Procedure Zap;
  924. begin
  925.    ConfirmUsedArea;
  926.    DBFActive^.Zap;
  927. end;
  928.  
  929. {------------------------------------------------------------------------------
  930.                            Field Access Routines
  931. ------------------------------------------------------------------------------}
  932.  
  933. Procedure AssignMemo(st, nm : string);
  934. var
  935.    i,
  936.    ml   : integer;
  937.    Txfile : Text;
  938. begin
  939.    Assign(TxFile,nm);
  940.    Rewrite(TxFile);
  941.    DBFActive^.MemoGet(st);
  942.    ml := DBFActive^.MemoLines;
  943.    if ml <> 0 then
  944.       for i := 1 to ml do
  945.          Writeln(TxFile,DBFActive^.MemoGetLine(i));
  946.    Close(TxFile);
  947. end;
  948.  
  949. procedure SaveMemo(st, nm : string);
  950. var
  951.    i   : integer;
  952.    s   : string;
  953.    m1,
  954.    m2  : string[10];
  955.    Txfile : Text;
  956. begin
  957.    m1 := DBFActive^.FieldGet(st);
  958.    DBFActive^.MemoClear;
  959.    Assign(TxFile,nm);
  960.    Reset(TxFile);
  961.    while not EOF(TxFile) do
  962.    begin
  963.       Readln(TxFile,s);
  964.       DBFActive^.MemoInsLine(-1,s);
  965.    end;
  966.    Close(TxFile);
  967.    DBFActive^.MemoPut(st);
  968.    m2 := DBFActive^.FieldGet(st);
  969.             {If the memo field number has changed, save the DBF record}
  970.    if m1 <> m2 then DBFActive^.PutRec(DBFActive^.RecNumber);
  971. end;
  972.  
  973. Procedure MemoClear;
  974. begin
  975.    DBFActive^.MemoClear;
  976. end;
  977.  
  978. function MemoGetLine(linenum : integer) : string;
  979. begin
  980.    MemoGetLine := DBFActive^.MemoGetLine(linenum);
  981. end;
  982.  
  983. Procedure MemoInsLine(linenum : integer; st : string);
  984. begin
  985.    DBFActive^.MemoInsLine(linenum, st);
  986. end;
  987.  
  988. procedure MemoGet(st : string);
  989. begin
  990.    DBFActive^.MemoGet(st);
  991. end;
  992.  
  993. procedure MemoGetN(n : integer);
  994. begin
  995.    DBFActive^.MemoGetN(n);
  996. end;
  997.  
  998. Procedure MemoWidth(l : integer);
  999. begin
  1000.    DBFActive^.MemoWidth(l);
  1001. end;
  1002.  
  1003. function MemoLines : integer;
  1004. begin
  1005.    MemoLines := DBFActive^.Memolines;
  1006. end;
  1007.  
  1008. procedure MemoPut(st : string);
  1009. begin
  1010.    DBFActive^.MemoPut(st);
  1011. end;
  1012.  
  1013. procedure MemoPutN(n : integer);
  1014. begin
  1015.    DBFActive^.MemoPutN(n);
  1016. end;
  1017.  
  1018. Function DateGet(st : string) : longint;
  1019. begin
  1020.    DateGet := DBFActive^.DateGet(st);
  1021. end;
  1022.  
  1023. Function DateGetN(n : integer) : longint;
  1024. begin
  1025.    DateGetN := DBFActive^.DateGetN(n);
  1026. end;
  1027.  
  1028. Procedure DatePut(st : string; jdte : longint);
  1029. begin
  1030.    DBFActive^.DatePut(st, jdte);
  1031. end;
  1032.  
  1033. Procedure DatePutN(n : integer; jdte : longint);
  1034. begin
  1035.    DBFActive^.DatePutN(n, jdte);
  1036. end;
  1037.  
  1038. Function FieldGet(fnam : string) : string;
  1039. begin
  1040.    FieldGet := DBFActive^.FieldGet(fnam);
  1041. end;
  1042.  
  1043. Function FieldGetN(fnum : integer) : string;
  1044. begin
  1045.    FieldGetN := DBFActive^.FieldGetN(fnum);
  1046. end;
  1047.  
  1048. Procedure FieldPut(fnam, st : string);
  1049. begin
  1050.    DBFActive^.FieldPut(fnam, st);
  1051. end;
  1052.  
  1053. Procedure FieldPutN(fnum : integer; st : string);
  1054. begin
  1055.    DBFActive^.FieldPutN(fnum, st);
  1056. end;
  1057.  
  1058. Function LogicGet(st : string) : boolean;
  1059. begin
  1060.    LogicGet := DBFActive^.LogicGet(st);
  1061. end;
  1062.  
  1063. Function LogicGetN(n : integer) : boolean;
  1064. begin
  1065.    LogicGetN := DBFActive^.LogicGetN(n);
  1066. end;
  1067.  
  1068. Procedure LogicPut(st : string; b : boolean);
  1069. begin
  1070.    DBFActive^.LogicPut(st, b);
  1071. end;
  1072.  
  1073. Procedure LogicPutN(n : integer; b : boolean);
  1074. begin
  1075.    DBFActive^.LogicPutN(n, b);
  1076. end;
  1077.  
  1078. Function NumberGet(st : string) : FloatNum;
  1079. begin
  1080.    NumberGet := DBFActive^.NumberGet(st);
  1081. end;
  1082.  
  1083. Function NumberGetN(n : integer) : FloatNum;
  1084. begin
  1085.    NumberGetN := DBFActive^.NumberGetN(n);
  1086. end;
  1087.  
  1088. Procedure NumberPut(st : string; r : FloatNum);
  1089. begin
  1090.    DBFActive^.NumberPut(st, r);
  1091. end;
  1092.  
  1093. Procedure NumberPutN(n : integer; r : FloatNum);
  1094. begin
  1095.    DBFActive^.NumberPutN(n, r);
  1096. end;
  1097.  
  1098. Function StringGet(fnam : string) : string;
  1099. begin
  1100.    StringGet := DBFActive^.StringGet(fnam);
  1101. end;
  1102.  
  1103. Function StringGetN(fnum : integer) : string;
  1104. begin
  1105.    StringGetN := DBFActive^.StringGetN(fnum);
  1106. end;
  1107.  
  1108. Procedure StringPut(fnam, st : string);
  1109. begin
  1110.    DBFActive^.StringPut(fnam, st);
  1111. end;
  1112.  
  1113. Procedure StringPutN(fnum : integer; st : string);
  1114. begin
  1115.    DBFActive^.StringPutN(fnum, st);
  1116. end;
  1117.  
  1118.  
  1119.  
  1120.  
  1121. {------------------------------------------------------------------------------
  1122.                            Setup and Exit Routines
  1123. ------------------------------------------------------------------------------}
  1124.  
  1125. var
  1126.    ExitSave      : pointer;
  1127.  
  1128. {$F+}
  1129. procedure ExitHandler;
  1130. var
  1131.    i    : integer;
  1132. begin
  1133.    CloseDatabases;
  1134.    ExitProc := ExitSave;
  1135. end;
  1136. {$F-}
  1137.  
  1138. begin
  1139.    ExitSave := ExitProc;
  1140.    ExitProc := @ExitHandler;
  1141.    CapError := DefCapError;
  1142.    CapStatus := DefCapStatus;
  1143.    DBFActive := nil;
  1144.    for DBFUsed := 0 to 40 do
  1145.    begin
  1146.       DBFAreas[DBFUsed] := nil;
  1147.    end;
  1148.    DBFUsed := 1;
  1149.    LastError := 0;
  1150. end.
  1151. {-----------------------------------------------------------------------------}
  1152.                                    END
  1153.  
  1154.